home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Tcl-Tk 8.0 / Pre-installed version / tcl8.0 / tests / load.test < prev    next >
Encoding:
Text File  |  1997-08-15  |  6.5 KB  |  161 lines  |  [TEXT/ALFA]
  1. # Commands covered:  load
  2. #
  3. # This file contains a collection of tests for one or more of the Tcl
  4. # built-in commands.  Sourcing this file into Tcl runs the tests and
  5. # generates output for errors.  No output means no errors were found.
  6. #
  7. # Copyright (c) 1995 Sun Microsystems, Inc.
  8. #
  9. # See the file "license.terms" for information on usage and redistribution
  10. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  11. #
  12. # SCCS: @(#) load.test 1.19 96/11/30 16:05:18
  13.  
  14. if {[string compare test [info procs test]] == 1} then {source defs}
  15.  
  16. # Figure out what extension is used for shared libraries on this
  17. # platform.
  18.  
  19. if {$tcl_platform(platform) == "macintosh"} {
  20.     puts "can't run dynamic library tests on macintosh machines"
  21.     return
  22. }
  23. set ext [info sharedlibextension]
  24. set testDir [file join [file dirname [info nameofexecutable]] dltest]
  25. if ![file readable [file join $testDir pkga$ext]] {
  26.     puts "libraries in $testDir haven't been compiled: skipping tests"
  27.     return
  28. }
  29.  
  30. if [string match *pkga* [set alreadyLoaded [info loaded {}]]] {
  31.     puts "load tests have already been run once:  skipping (can't rerun)"
  32.     return
  33. }
  34.  
  35. set alreadyTotalLoaded [info loaded]
  36.  
  37. test load-1.1 {basic errors} {
  38.     list [catch {load} msg] $msg
  39. } {1 {wrong # args: should be "load fileName ?packageName? ?interp?"}}
  40. test load-1.2 {basic errors} {
  41.     list [catch {load a b c d} msg] $msg
  42. } {1 {wrong # args: should be "load fileName ?packageName? ?interp?"}}
  43. test load-1.3 {basic errors} {
  44.     list [catch {load a b foobar} msg] $msg
  45. } {1 {couldn't find slave interpreter named "foobar"}}
  46. test load-1.4 {basic errors} {
  47.     list [catch {load {}} msg] $msg
  48. } {1 {must specify either file name or package name}}
  49. test load-1.5 {basic errors} {
  50.     list [catch {load {} {}} msg] $msg
  51. } {1 {must specify either file name or package name}}
  52. test load-1.6 {basic errors} {
  53.     list [catch {load {} Unknown} msg] $msg
  54. } {1 {package "Unknown" isn't loaded statically}}
  55.  
  56. test load-2.1 {basic loading, with guess for package name} {
  57.     load [file join $testDir pkga$ext]
  58.     list [pkga_eq abc def] [info commands pkga_*]
  59. } {0 {pkga_eq pkga_quote}}
  60. interp create -safe child
  61. test load-2.2 {loading into a safe interpreter, with package name conversion} {
  62.     load [file join $testDir pkgb$ext] pKgB child
  63.     list [child eval pkgb_sub 44 13] [catch {child eval pkgb_unsafe} msg] $msg \
  64.         [catch {pkgb_sub 12 10} msg2] $msg2
  65. } {31 1 {invalid command name "pkgb_unsafe"} 1 {invalid command name "pkgb_sub"}}
  66. test load-2.3 {loading with no _Init procedure} {
  67.     list [catch {load [file join $testDir pkgc$ext] foo} msg] $msg
  68. } {1 {couldn't find procedure Foo_Init}}
  69. test load-2.4 {loading with no _SafeInit procedure} {
  70.     list [catch {load [file join $testDir pkga$ext] {} child} msg] $msg
  71. } {1 {can't use package in a safe interpreter: no Pkga_SafeInit procedure}}
  72.  
  73. test load-3.1 {error in _Init procedure, same interpreter} {
  74.     list [catch {load [file join $testDir pkge$ext] pkge} msg] $msg $errorInfo $errorCode
  75. } {1 {couldn't open "non_existent": no such file or directory} {couldn't open "non_existent": no such file or directory
  76.     while executing
  77. "open non_existent"
  78.     invoked from within
  79. "load [file join $testDir pkge$ext] pkge"} {POSIX ENOENT {no such file or directory}}}
  80. test load-3.2 {error in _Init procedure, slave interpreter} {
  81.     catch {interp delete x}
  82.     interp create x
  83.     set errorCode foo
  84.     set errorInfo bar
  85.     set result [list [catch {load [file join $testDir pkge$ext] pkge x} msg] \
  86.         $msg $errorInfo $errorCode]
  87.     interp delete x
  88.     set result
  89. } {1 {couldn't open "non_existent": no such file or directory} {couldn't open "non_existent": no such file or directory
  90.     while executing
  91. "open non_existent"
  92.     invoked from within
  93. "load [file join $testDir pkge$ext] pkge x"} {POSIX ENOENT {no such file or directory}}}
  94.  
  95. test load-4.1 {reloading package into same interpreter} {
  96.     list [catch {load [file join $testDir pkga$ext] pkga} msg] $msg
  97. } {0 {}}
  98. test load-4.2 {reloading package into same interpreter} {
  99.     list [catch {load [file join $testDir pkga$ext] pkgb} msg] $msg
  100. } "1 {file \"[file join $testDir pkga$ext\"] is already loaded for package \"Pkga\"}"
  101.  
  102. test load-5.1 {file name not specified and no static package: pick default} {
  103.     catch {interp delete x}
  104.     interp create x
  105.     load [file join $testDir pkga$ext] pkga
  106.     load {} pkga x
  107.     set result [info loaded x]
  108.     interp delete x
  109.     set result
  110. } "{[file join $testDir pkga$ext] Pkga}"
  111.  
  112. # On some platforms, like SunOS 4.1.3, these tests can't be run because
  113. # they cause the process to exit.
  114.  
  115. test load-6.1 {errors loading file} {nonPortable} {
  116.     catch {load foo foo}
  117. } {1}
  118.  
  119. if {[info command teststaticpkg] != ""} {
  120.     test load-7.1 {Tcl_StaticPackage procedure} {
  121.     set x "not loaded"
  122.     teststaticpkg Test 1 0
  123.     load {} Test
  124.     load {} Test child
  125.     list [set x] [child eval set x]
  126.     } {loaded loaded}
  127.     test load-7.2 {Tcl_StaticPackage procedure} {
  128.     set x "not loaded"
  129.     teststaticpkg Another 0 0
  130.     load {} Another
  131.     child eval {set x "not loaded"}
  132.     list [catch {load {} Another child} msg] $msg [child eval set x] [set x]
  133.     } {1 {can't use package in a safe interpreter: no Another_SafeInit procedure} {not loaded} loaded}
  134.     test load-7.3 {Tcl_StaticPackage procedure} {
  135.     set x "not loaded"
  136.     teststaticpkg More 0 1
  137.     load {} More
  138.     set x
  139.     } {not loaded}
  140.     test load-7.4 {Tcl_StaticPackage procedure, redundant calls} {
  141.     teststaticpkg Double 0 1
  142.     teststaticpkg Double 0 1
  143.     info loaded
  144.     } "{{} Double} {{} More} {{} Another} {{} Test} {[file join $testDir pkge$ext] Pkge} {[file join $testDir pkgb$ext] Pkgb} {[file join $testDir pkga$ext] Pkga} $alreadyTotalLoaded"
  145.  
  146.     test load-8.1 {TclGetLoadedPackages procedure} {
  147.     info loaded
  148.     } "{{} Double} {{} More} {{} Another} {{} Test} {[file join $testDir pkge$ext] Pkge} {[file join $testDir pkgb$ext] Pkgb} {[file join $testDir pkga$ext] Pkga} $alreadyTotalLoaded"
  149.     test load-8.2 {TclGetLoadedPackages procedure} {
  150.     list [catch {info loaded gorp} msg] $msg
  151.     } {1 {couldn't find slave interpreter named "gorp"}}
  152.     test load-8.3 {TclGetLoadedPackages procedure} {
  153.     list [info loaded {}] [info loaded child]
  154.     } "{{{} Double} {{} More} {{} Another} {{} Test} {[file join $testDir pkga$ext] Pkga} $alreadyLoaded} {{{} Test} {[file join $testDir pkgb$ext] Pkgb}}"
  155.     test load-8.4 {TclGetLoadedPackages procedure} {
  156.     load [file join $testDir pkgb$ext] pkgb
  157.     list [info loaded {}] [lsort [info commands pkgb_*]]
  158.     } "{{[file join $testDir pkgb$ext] Pkgb} {{} Double} {{} More} {{} Another} {{} Test} {[file join $testDir pkga$ext] Pkga} $alreadyLoaded} {pkgb_sub pkgb_unsafe}"
  159.     interp delete child
  160. }
  161.